Pascal Super Library/Pascal Super Library (CW International)(1997).bin/PGM_TOOL/PREVIEW/MISC.PAS

Pascal/Delphi Source File | 1995-11-12 | 10KB | 427 lines

Unit Misc;

Interface

uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
     Forms, Dialogs, StdCtrls, Buttons, wYNform;

Const MaxPars=20;
      UPARROW=38; { in KeyDown events, GetUp(),GetDown(),GetEsc() }
      DNARROW=40;
      ESCKEY=27;
      RETKEY=13;
      RETCHAR=#13;  { in KeyPress events, GetRet() }
      NULLCHAR=#0;
      DNCHAR=#40;
      UPCHAR=#38;
      ESCCHAR=#27;

Type
  String135=String[137];
  String30=String[31];
  GenVars=class(TObject)
      public
      { used to store BluePrint Images }
      User:string[10];
        FullBP,TinyBP,PrintBP:TBitMap;
      InBluePrint:boolean; { only allow one open at a time }
            procedure AddWin(astr:string;aform:Tform);
      procedure ReleaseWin(aform:Tform);
    end;

procedure StartMisc;
procedure StopMisc;
function  Pin(str1,instr2:string):boolean;  { pos()>0 }
function  uPin(str1,instr2:string):boolean;  { pos()>0 }
function  YesNoBox(text:string):boolean;
function  iifs(abool:boolean;ret1,ret2:string):string;
function  Empty(aStr:String):Boolean;
function  ProcInt(nval:string):integer;
function  ProcDbl(nval:string):double;
procedure split(orgline,pchar:string;
            var resarr:array of string135;var rescnt:integer);
function  Trim(aStr:String):String;   { trim off trailing spaces }
function  pp(var anInt:integer):integer;  { ii:=ii+1  ==>  pp(ii) }
function  iifi(abool:boolean;ret1,ret2:integer):integer;
function  lTrim(aStr:String):String;   { trim off leading spaces }
procedure OKbox(sText:String);
function  GetRet(var aChar:char):boolean;
function  PadR(aStr:String;InWidth:Integer):String; { left justify in width }
function  Space(EmptySize:Integer):String;  { return string of spaces }
procedure MouseWait;
procedure MouseGo;
procedure CenterHoriz(aform:Tform);
function  Upper(aStr:string):string;
function  SubStr(astr:string;fromm,too:integer):string;
function  unsplit(var arr1:array of string135;delim:string;acnt:integer):string;
function  StrD(aDbl:double;ToPlaces:integer):string;
function  Str(aDbl:double;width,decs:integer):string;
function  StrI(aInt:longint;width:integer):string;
function  ComPath(aFile:string):string;
function  PadL(aStr:String;InWidth:Integer):String; { right justify in width }
procedure DoEvents;
procedure DoEvents2;
var Gen:GenVars;

Implementation

function  ComPath(aFile:string):string;
begin
  result:=aFile;
end;

function PadL(aStr:String;InWidth:Integer):String; { right justify in width }
var ll:integer;
begin
    ll:=length(aStr);
    if ll>=InWidth then Result:=copy(aStr,1,Inwidth)  { truncate }
    else Result:=space(InWidth-ll)+aStr;
end;

procedure DoEvents;
begin
    Application.ProcessMessages;
end;

procedure DoEvents2;
begin
    Application.ProcessMessages;
end;

function str(aDbl:double;width,decs:integer):string;
var nines,before,after:string[30];
    ii:integer;
begin
    Result:=format('%*.*f',[width,decs,aDbl]);
end;

function StrI(aInt:longint;width:integer):string;
begin
  result:=padl(inttostr(aInt),width);
end;

function  StrD(aDbl:double;ToPlaces:integer):string;
var InWidth:integer;
begin
  InWidth:=8;
    if ToPlaces>0 then InWidth:=8+1+ToPlaces;
  Result:=ltrim(str(aDbl,InWidth,ToPlaces));
end;

function unsplit(var arr1:array of string135;delim:string;acnt:integer):string;
{ array may be 1 based, but when passed in it becomes 0 based }
var ii,jj,pp:integer;
    tt:string;
begin
  tt:='';
  if acnt=1 then begin
    tt:=arr1[0];
  End;
  if acnt>1 then begin
    for ii:=0 to acnt-2 do begin
      tt:=tt+arr1[ii]+delim;
    End;
    tt:=tt+arr1[acnt-1];
  End;
  Result:=tt;
end;

function  SubStr(astr:string;fromm,too:integer):string;
begin
  result:=copy(astr,fromm,too);
end;

procedure GenVars.AddWin(astr:string;aform:Tform);
begin
  { do nothing }
end;

procedure GenVars.ReleaseWin(aform:Tform);
begin
  { do nothing }
end;

function Upper(aStr:string):string;begin
  result:=uppercase(aStr);
end;

procedure CenterHoriz(aform:Tform);
var ii:integer;
begin
  ii:=(screen.width-aform.width-8) div 2;
  if ii<0 then aform.left:=0 else aform.left:=ii;
end;

procedure MouseWait;
begin
  Screen.Cursor:=crHourGlass;
  Application.ProcessMessages;
end;

procedure MouseGo;
begin
  Screen.Cursor:=crDefault;
  Application.ProcessMessages;
end;

function Space(EmptySize:Integer):String;  { return string of spaces }
var tt,tt2:string;
        ii:integer;
begin
    tt:='                              ';
    tt2:='';
    for ii:=1 to 5 do tt2:=tt2+tt;
    ii:=length(tt2);
    Result:=copy(tt2,1,EmptySize);
end;

function PadR(aStr:String;InWidth:Integer):String; { left justify in width }
var ll:integer;
begin
    ll:=length(aStr);
    if ll>=InWidth then Result:=copy(aStr,1,Inwidth)  { truncate }
    else Result:=aStr+space(InWidth-ll);
end;

function GetRet(var aChar:char):boolean;
begin
  if aChar=escchar then aChar:=nullchar;
  if aChar=retchar then begin
      aChar:=nullchar;
        Result:=true;
    end else Result:=false;
end;

procedure OKbox(sText:String);
var tyn:TYNform;
begin
  tyn:=TYNform.create(application);
  tyn.setup(1,'Job Cost',stext);
  tyn.showmodal;
end;

function lTrim(aStr:String):String;   { trim off trailing spaces }
var ii,kk,ll:integer;
begin
    ll:=length(aStr);
    Result:=aStr;
    if ll>0 then begin
        kk:=0;
        for ii:=1 to ll do begin
            if aStr[ii]<>#32 then begin
                kk:=ii;
                break;
            end;
        end;
        if kk>0 then Result:=copy(astr,kk,254)
        else Result:='';
    end;
end;

function iifi(abool:boolean;ret1,ret2:integer):integer;
{  iif() when params are integer's }
begin
  if abool then result:=ret1 else result:=ret2;
end;

function pp(var anInt:integer):integer;  { ii:=ii+1  ==>  pp(ii) }
begin
  result:=anInt;  { usage:  lp.p(line++,5,'Hi') -> lp.p(pp(line),5,'Hi') }
    anInt:=anInt+1;
end;

function  Pin(str1,instr2:string):boolean;  { pos()>0 }
begin
  result:=(pos(str1,instr2)>0);
end;

function  uPin(str1,instr2:string):boolean;  { pos()>0 }
begin
  result:=(pos(upper(str1),upper(instr2))>0);
end;

function  YesNoBox(text:string):boolean;
var ret:integer;
    tyn:TYNform;
begin
  tyn:=TYNform.create(application);
  tyn.setup(2,'Job Cost',text);
  ret:=tyn.showmodal;
    Result:=(ret=mrYES);
end;

function iifs(abool:boolean;ret1,ret2:string):string;
{  iif() when params are string's }
begin
  if abool then result:=ret1 else result:=ret2;
end;

procedure StartMisc;
begin
  Gen:=genvars.create;
  Gen.User:='BRAD ';
  Gen.FullBP:=tbitmap.create;
  Gen.TinyBP:=tbitmap.create;
  Gen.PrintBP:=tbitmap.create;
end;

procedure StopMisc;
begin
  Gen.free;
  Gen.FullBP.free;
  Gen.TinyBP.free;
  Gen.PrintBP.free;
end;

function Empty(aStr:String):Boolean;
var ii,ll:integer;
        res:boolean;
begin
    if length(aStr)=0 then res:=true
    else
    begin
        ll:=length(aStr);
        if (ll=8) or (ll=10) then { check for date? }
        begin
            if (aStr[3]=#47) and (aStr[6]=#47) then { chars 3 and 6 are "/" }
            begin
                ll:=2; { only need to test first 2 chars of dates }
                if pos('00',aStr)=1 then ll:=0  { ignore '00/00/00' }
            end;
        end;
        res:=True;
        if ll>0 then begin
            for ii:=1 to ll do begin
                if aStr[ii]<>#32 then begin
                    res:=False;
                    break;
                end;
            end;
        end;
    end;
    Result:=res;
end;

function  ProcInt(nval:string):integer;
var tdbl:double;
begin
  tdbl:=ProcDbl(nval);
  result:=StrToInt(format('%8.0f',[tdbl]));
end;

function procdbl(nval:string):double;
var decs,prnum,jj:double;
        ii:integer;
        ist:string[30];
        pastdec,isminus:boolean;
begin
    prnum:=0.00;
    pastdec:=False;
    isminus:=False;
    decs:=1.0;
    if not empty(nval) then begin
        for ii:=1 to length(nval) do begin
            ist:=Copy(nval,ii,1);
            if ist='-' then begin
                isminus:=True;
            End;
            if ist='.' then begin
                pastdec:=True;
            End Else
            Begin
                if (ist >= '0') And (ist <= '9') then begin
                    jj:=StrToFloat(ist);
                    prnum := prnum * 10.0;
                    prnum := prnum + jj;
                    if pastdec then begin
                        decs:=decs / 10.0;
                    End;
                End;
            End;
        End;
        if isminus then begin
            prnum:=prnum * decs * -1;
        End Else
        Begin
            prnum:=prnum * decs;
        End;
        if Not pastdec then begin
            prnum:=int(prnum);
        End;
    end;
    Result:=prnum;
end;

procedure split(orgline,pchar:string;
  var resarr:array of string135;var rescnt:integer);
var aline:string;
    ii,jj,kk,acnt,plen:integer;
        ats:array [1..80] of integer;
begin
  for ii:=0 to high(resarr) do resarr[ii]:='';
  rescnt:=0;
  for ii:=1 to 80 do ats[ii]:=0;
  aline:=orgline;
  jj:=length(aline);
  plen:=length(pchar);
  if jj>0 then begin
    rescnt:=1;
    ats[rescnt]:=0;
    for ii:=1 to jj do begin
      if Copy(aline,ii,plen)=pchar then begin
        rescnt:=rescnt+1;
        ats[rescnt]:=ii;
      End;
    End;
    ats[rescnt+1]:=jj;
    if rescnt=1 then begin
      resarr[0]:=aline;
    End Else
    Begin
      for ii:=1 to rescnt do begin
        if ii=1 then begin
          kk:=ats[ii+1]-ats[ii]-1;
          if kk>0 then begin
            resarr[ii-1]:=Copy(aline,1,kk);
          End;
        end else
        if ii=rescnt then begin
          kk:=ats[ii+1]-ats[ii]-plen+1;
          if kk>0 then begin
            resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
          End;
        end Else
        begin
          kk:=ats[ii+1]-ats[ii]-plen;
          if kk>0 then begin
            resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
          End;
        End;
      End;
    End;
  End;
end;

function Trim(aStr:String):String;   { trim off trailing spaces }
var ii,kk,ll:integer;
begin
    ll:=length(aStr);
    Result:=aStr;
    if ll>0 then begin
        kk:=0;
        for ii:=ll downto 1 do begin
            if aStr[ii]<>#32 then begin
                kk:=ii;
                break;
            end;
        end;
        if kk>0 then Result:=copy(astr,1,kk)
        else Result:='';
    end;
end;




end.